home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / compo-demo.stklos < prev    next >
Encoding:
Text File  |  1996-04-23  |  4.5 KB  |  134 lines
  1. #!/bin/sh
  2. :;exec /usr/local/bin/stk -f "$0" "$@"
  3. ;;
  4. ;; A quick demo of the composite widgets
  5. ;; This code is a contribution of Drew.Whitehouse@anu.edu.au
  6. ;;
  7. ;; Multiple-window added by eg on 96/04/14
  8.  
  9. (require "Tk-classes")
  10.  
  11. (define main-frame (make <Frame>))
  12. (define title (make <Label> :parent main-frame :text "Composite Widgets Demo"))
  13. (define button-box (make <Frame> :parent main-frame :width 200 :height 100))
  14. (define quit (make <Button> :parent main-frame 
  15.                    :text " quit "
  16.                    :command (lambda () 
  17.                   (destroy *root*))))
  18.  
  19. (define composite-widgets '(Choicebox 
  20.                             Defbutton 
  21.                             Filebox 
  22.                             Lentry 
  23.                             Paned 
  24.                             Scrollbox
  25.                 Multiwin))
  26. (for-each (lambda (x)
  27.             (let ((cmd (string-append "(demo-" (symbol->string x) ")")))
  28.               (pack (make <Button> :parent button-box :text x :command cmd)
  29.                     :fill 'x :padx 5 )))
  30.           composite-widgets)
  31.  
  32. (pack title button-box :fill 'x :padx 10 :pady 10)
  33. (pack quit :padx 10 :pady 10 )
  34. (pack main-frame)
  35.  
  36. (define (demo-choicebox)
  37.   (let* ((tl (make <Toplevel> :title "Choice Box"))
  38.          (cb (make <Choice-box> :value "empty for now!" :parent tl)))
  39.     ;; add some entries
  40.     (for-each (lambda (x) (add-choice cb (symbol->string x))) 
  41.           composite-widgets)
  42.     (pack cb)))
  43.  
  44. (define (demo-defbutton)
  45.   (pack (make <Default-button> 
  46.           :text "button"
  47.           :width 20
  48.           :parent (make <Toplevel> :title "Default Button"))))
  49.          
  50. (define (demo-filebox)
  51.   (let ((f (make-file-box)))
  52.     (if f
  53.     (format #t "You have selected ~S\n" f)
  54.     (format #t "Cancel\n"))))
  55.  
  56. (define (demo-lentry)
  57.   (pack (make <Labeled-entry> 
  58.           :title "title" 
  59.           :parent (make <Toplevel> :title "Labeled entry"))
  60.     :padx 5 :pady 5))
  61.     
  62. (define (demo-paned)
  63.   (let* ((tl (make <Toplevel> :title "Paned demo"))
  64.          (hp (make <HPaned> :fraction 0.3 :width 300 :height 300 :parent tl))
  65.          (f1 (make <Label> :text "top pane" :parent (top-frame-of hp)))
  66.          (f2 (make <Label> :text "bottom-pane" :parent (bottom-frame-of hp)))
  67.          (vp (make <VPaned> :fraction 0.3 :width 300 :height 300 :parent tl))
  68.          (f3 (make <Label> :text "left pane" :parent (left-frame-of vp)))
  69.          (f4 (make <Label> :text "right-pane" :parent (right-frame-of vp))))
  70.     (pack f1 f2 f3 f4 :expand #t)
  71.     (pack hp vp)))
  72.  
  73. (define (demo-scrollbox)
  74.   (let* ((tl (make <Toplevel> :title "Scroll box"))
  75.          (sb (make <Scroll-listbox> :parent tl :geometry "20x6")))
  76.     ;; add some entries into the listbox
  77.     (for-each (lambda (x) 
  78.                 (insert (listbox-of sb) 0 x))
  79.               (append composite-widgets composite-widgets))
  80.     (pack sb)))
  81.  
  82.  
  83. (define (demo-multiwin) 
  84.   ;;
  85.   ;; Make a Menu bar
  86.   ;;
  87.   (define tl   (make <Toplevel> :title "Multiple and Inner windows demo"))
  88.   (define top  (make <Frame> :parent tl))
  89.   (define col '#("violet" "skyblue1" "Misty Rose" "Plum" "grey40"))
  90.   (define menu (make-menubar top 
  91.      `(("Menu" 
  92.     ("Add one"  ,(let ((counter 0))
  93.                (lambda () 
  94.              (place (make <Inner-window> :parent f
  95.                       :title (format #f "Window #~A" counter)
  96.                       :background (vector-ref col (random 5)))
  97.                 :x (random 200) :y (random 200))
  98.              (set! counter (1+ counter)))))
  99.     ("")
  100.     ("Quit"     ,(lambda () (destroy tl)))))))
  101.   (pack menu :side "left" :expand #f)
  102.   (pack top :fill "x")
  103.   ;;
  104.   ;; Make a multiple window
  105.   ;;
  106.   (define f (make <Multiple-window> :parent tl :background "cyan4"))
  107.   (pack f :fill "both" :expand #t)
  108.  
  109.   ;;
  110.   ;; First child
  111.   ;;
  112.   (define f1 (make <Inner-window> :parent f :title "A Text window"))
  113.   (define t1 (make <Scroll-Text> :highlight-thickness 0 :parent f1 :height 8 
  114.            :background "lightblue3" :wrap "word"
  115.            :value "Hi!I'm a text window\n\n\n\n\n\n\n\n\n\n\n\n\n\n\nEnd"))
  116.   (define t2 (make <Scroll-Text> :highlight-thickness 0 :parent f1 
  117.            :background "lightblue3" :wrap "word"
  118.            :value "Hi, I'm also embedded in a window.\nUse the mouse in the border of my enclosing window to enlarge or shrink this editor"))
  119.   (pack t1 t2 :fill "both" :expand #t)
  120.   (place f1 :x 100 :y 70)
  121.  
  122.   ;;
  123.   ;; Second child
  124.   ;;
  125.   (define f2 (make <Inner-window> :parent f :title "A canvas window"))
  126.   (define c1 (make <Canvas> :parent f2 :background "#c4b6a7"))
  127.   (make <Rectangle> :parent c1 :fill "IndianRed1"     :coords '(0 0 50 50))
  128.   (make <Oval>      :parent c1 :fill "DarkOliveGreen" :coords '(100 100 150 150))
  129.   (bind-for-dragging c1)
  130.   (pack c1 :fill "both" :expand #t)
  131.   (place f2 :x 10 :y 10))
  132.  
  133.  
  134.